home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
progjour
/
1988
/
01
/
chilc
/
mazil2.for
< prev
next >
Wrap
Text File
|
1987-09-03
|
12KB
|
168 lines
C* SUBROUTINE MAZIL2
C*
C* \PE HA\HA\EHA \\ B\BO A -PA \KOB TA\\\\HO OR AHH\X
C* \HK \\ ( C PABH\M \A-OM ) HA A \\
C*
C* OPMA\\H\E \APAMETP\:
C*
C* L1 FIELD - \T\M\ C\MBO\AM\ \\ ET \A\O\HEHO BCE \O\E -PA \KA
C* O\\\HO B KA\ECTBE FIELD \A AETC\ \PO\E\
C* L1 EQSMBL - \T\M\ C\MBO\AM\ \O \MO\\AH\8 \E\ATA8TC\ BCE
C* -PA \K\, \O \E\A\\E B\BO \
C* L LEQ - OTMEHA \MO\\AH\\ HA B\\OP C\MBO\OB, \C\O\\\\EM\X
C* \\ \E\AT\ -PA \KOB. \P\ LEQ = .FALSE.
C* COOTBETCTB\8\\E C\MBO\\ \\ \T HA\ EH\ B MACC\BE
C* SMBLS (CM.H\\E)
C* INT NFUN - KO\\\ECBO \HK \\, \O \E\A\\X B\BO \
C*
C* INT N - \\C\O TO\EK -PA \KA, OTHOC\\\XC\ K O HO\
C* \HK \\ ( PABHO \\ BCEX NFUN \HK \\ )
C* R FUN - TA\\\ A \HA\EH\\ \HK \\, \O \E\A\\X B\BO \
C* ( MATP\ A, CO EP\A\A\ NFUN CTO\\ OB \ N CTPOK )
C* L1 SMBLS - MACC\B, CO EP\A\\\ TA\\\ \ C\MBO\OB \\ \E\AT\
C* -PA \KOB ( \P\ LEQ = .FALSE. ), \P\\EM BCE
C* C\MBO\\ MO-\T \\T\ PA\\\\H\M\
C* R8 LBX - HA\A\HOE \HA\EH\E \EPEMEHHO\ X
C*
C* R8 STX - \A- B O\\ X
C*
C* R8 LBY - H\\H\\ -PAH\ A B\BO \M\X \HA\EH\\ Y
C*
C* R8 SCY - \KA\A Y
C*
C* INT GR - \E\AT\ CETK\ HA -PA \KE ( 0-HE \E\., 1-\O X,
C* 2-\O Y, 3-\O X \ \O Y
C* INT DIGY - \E\AT\ O \ POBK\ OC\ Y ( 0-HE \E\., 1-TO\\KO
C* BHA\A\E, 2-TO\\KO B KOH E, 3-BHA\A\E \ B KOH E )
C* INT GRINTX - \HTEPBA\ CETK\ \O X ( \EPE\ GRINTX TO\EK X
C* \POBO \T\ \\H\8 CETK\ ).
C* INT FSTNX - HA\A\\HOE \HA\EH\E HOMEPA AP-\MEHTA X ( HOMEPA
C* TO\EK \E\ATA8TC\ HAP\ \ CO \HA\EH\\M\ X ).
C* L LALLX - \E\ATAT\ BCE \HA\EH\\ AP-\MEHTA X ( LALLX=.TRUE.)
C* \\\ TO\\KO 'CETO\H\E' ( LALLX=.FALSE.)
C*
C* INT NEMP - \\C\O \\CT\X CTPOK, BCTAB\\EM\X ME\ \ COCE H\M\
C* CTPOKAM\, CO EP\A\\M\ TO\K\ -PA \KA
C*
C* V.V.KHOTKEVICH, A.V.KHOTKEVICH (PTILT AS UKRSSR)
C* ISSUED 06.06.85
C*
C*
SUBROUTINE MAZIL2 (FIELD,EQSMBL,LEQ,NFUN,N,FUN,SMBLS,LBX,STX,
& LBY,SCY,GR,DIGY,GRINTX,FSTNX,LALLX,NEMP)
C
INTEGER NFUN,N,GR,DIGY,GRINTX,FSTNX,NEMP
LOGICAL*1 FIELD,EQSMBL,SMBLS(NFUN)
LOGICAL LEQ,LALLX
REAL FUN(N,NFUN)
REAL*8 LBX,STX,LBY,SCY
C
INTEGER GRX,GRY,GRXY,DIGYF,DIGYL,DIGYFL
INTEGER NUM,NX,NJ,ARG,NN,J,I,II,POS,FCONTR,ALL,K
LOGICAL*1 PALKA,HYPHEN,PLUS,S(101)
LOGICAL GX,GY
REAL*8 RESY,X,E,GREEDY(11)
REAL*8 DBLE
C
11 FORMAT(18X,11(1X,G9.3))
22 FORMAT(19X,101A1)
33 FORMAT(9X,G9.3,1X,101A1)
44 FORMAT(2X,I5,12X,101A1)
55 FORMAT(2X,I5,2X,G9.3,1X,101A1)
C
DATA PALKA/1H|/, HYPHEN/1H-/, PLUS/1H+/
DATA GRX/1/, GRY/2/, GRXY/3/, DIGYF/1/, DIGYL/2/, DIGYFL/3/
C
GX = .FALSE.
GY = .FALSE.
IF (GR .EQ. GRX .OR. GR .EQ. GRXY) GX = .TRUE.
IF (GR .EQ. GRY .OR. GR .EQ. GRXY) GY = .TRUE.
NUM = 0
NX = FSTNX
IF (NX .GT. 0) NUM = 2
IF (NX .LE. 0) NX = 1
ALL = 0
IF (LALLX) ALL = 1
RESY = (SCY-LBY) * 1.D-2
DO 10 I = 1, 11
GREEDY(I) = LBY + DBLE(I-1) * (SCY-LBY) * 1.D-1
10 CONTINUE
IF (DIGY .EQ. DIGYF .OR. DIGY .EQ. DIGYFL) WRITE(5,11) GREEDY
NJ = 1
DO 200 J = 1, N
ARG = 1
DO 20 I = 2, 100
S(I) = FIELD
20 CONTINUE
S(1) = PALKA
S(101) = PALKA
X = LBX + DBLE(J-1) * STX
NN = J - 1 + NX
IF (.NOT. GY) GO TO 40
DO 30 I = 2, 10
II = (I-1) * 10 + 1
S(II) = PALKA
30 CONTINUE
40 CONTINUE
IF (J .EQ. 1 .OR. J .EQ. N) GO TO 42
IF (J .NE. (NJ-1)*GRINTX+1) GO TO 70
42 CONTINUE
IF (.NOT. LALLX) ARG = 2
NJ = NJ + 1
IF (J .EQ. 1 .OR. J .EQ. N) GO TO 45
IF (.NOT. GX) GO TO 70
45 CONTINUE
DO 50 I = 2, 100
S(I) = HYPHEN
50 CONTINUE
DO 60 I = 1, 11
II = (I-1) * 10 + 1
S(II) = PLUS
60 CONTINUE
70 CONTINUE
DO 90 I = 1, NFUN
E = (FUN(J,I) - LBY) / RESY + 1.D0
POS = E
II = E + 0.5D0
IF (II .GT. POS) POS = POS + 1
IF (POS .LT. 1 .OR. POS .GT. 101) GO TO 80
S(POS) = SMBLS(I)
IF (LEQ) S(POS) = EQSMBL
80 CONTINUE
90 CONTINUE
FCONTR = ARG + ALL + NUM
GO TO (100,110,120,130), FCONTR
100 CONTINUE
WRITE(5,22) S
GO TO 140
110 CONTINUE
WRITE(5,33) X,S
GO TO 140
120 CONTINUE
WRITE(5,44) NN,S
GO TO 140
130 CONTINUE
WRITE(5,55) NN,X,S
140 CONTINUE
IF (NEMP .LE. 0) GO TO 190
IF (J .EQ. N) GO TO 190
DO 180 I = 1, NEMP
DO 150 II = 2, 100
S(II) = FIELD
150 CONTINUE
IF (.NOT. GY) GO TO 170
DO 160 II = 2, 10
K = (II-1) * 10 + 1
S(K) = PALKA
160 CONTINUE
170 CONTINUE
S(1) = PALKA
S(101) = PALKA
WRITE(5,22) S
180 CONTINUE
190 CONTINUE
200 CONTINUE
IF (DIGY .EQ. DIGYL .OR. DIGY .EQ. DIGYFL) WRITE(5,11) GREEDY
RETURN
END